home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / ptv1n1.arc / PACKED.SRC < prev    next >
Text File  |  1990-06-08  |  1KB  |  36 lines
  1.  
  2. function PackedUp(Original: string): string;
  3.   { Take a string of characters and compress it down at a ratio
  4.     of 5:8 by converting all characters into a 5 bit code. Only
  5.     letters are unique, numbers are bunched together as are
  6.     punctuation. }
  7.   var I: word;
  8.       J: word;
  9.       BitMask: word;
  10.       ShiftFactor: word;
  11.       ResultStr: string;
  12. begin
  13.   fillchar(ResultStr,sizeof(ResultStr),0);     { Initialize
  14. result }
  15.   J := 1;
  16.   for I := 1 to length(Original) do  { Pack each of the
  17. characters }
  18.     begin
  19.     ShiftFactor := (I+I+I) and 7;
  20.     case Original[I] of
  21.       '0'..'9': BitMask := 27;
  22.       'a'..'z','A'..'Z': BitMask := ord(Original[I]) and $1F
  23.       else BitMask := 0
  24.       end;
  25.     BitMask := BitMask shl ShiftFactor;
  26.     ResultStr[J] := chr(ord(ResultStr[J]) or lo(BitMask));
  27.     ResultStr[pred(J)] := chr(ord(ResultStr[pred(J)]) or
  28.                               hi(BitMask));
  29.     if ShiftFactor < 5 then
  30.       inc(J)
  31.     end;
  32.   ResultStr[0] := chr((5*length(Original)+7) shr 3);  { Set
  33. length }
  34.   PackedUp := ResultStr
  35. end;
  36.